home *** CD-ROM | disk | FTP | other *** search
/ Windows Game Programming for Dummies (2nd Edition) / WinGamProgFD.iso / mac / DirectX SDK / DXSDK / samples / Multimedia / VBSamples / Common / d3dutil.bas < prev    next >
BASIC Source File  |  2001-10-08  |  41KB  |  1,183 lines

  1. Attribute VB_Name = "D3DUtil"
  2.  
  3.  
  4. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  5. '
  6. '  Copyright (C) 1999-2001 Microsoft Corporation.  All Rights Reserved.
  7. '
  8. '  File:       D3DUtil.Bas
  9. '  Content:    VB D3DFramework utility module
  10. '
  11. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  12.  
  13. ' DOC:  Use with
  14. ' DOC:        D3DAnimation.cls
  15. ' DOC:        D3DFrame.cls
  16. ' DOC:        D3DMesh.cls
  17. ' DOC:        D3DSelectDevice.frm (optional)
  18. ' DOC:
  19. ' DOC:  Short list of usefull functions
  20. ' DOC:        D3DUtil_Init                  first call to framework
  21. ' DOC:        D3DUtil_LoadFromFile          loads an x-file
  22. ' DOC:        D3DUtil_SetupDefaultScene     setup a camera lights and materials
  23. ' DOC:        D3DUtil_SetupCamera           point camera
  24. ' DOC:        D3DUtil_SetupMediaPath        set directory to load textures from
  25. ' DOC:        D3DUtil_PresentAll            show graphic on the screen
  26. ' DOC:        D3DUtil_ResizeWindowed        resize for windowed modes
  27. ' DOC:        D3DUtil_ResizeFullscreen      resize to fullscreen mode
  28. ' DOC:        D3DUtil_CreateTextureInPool   create a texture
  29.  
  30.  
  31. Option Explicit
  32.  
  33.  
  34. ' DOC: DXLockArray8 & DXUnlockArray8
  35. ' DOC:
  36. ' DOC: These are Helper functions that allow textures, vertex buffers, and index buffers
  37. ' DOC: to look like VB arrays to the VB user.
  38. ' DOC: It is imperative that Lock be matched with unlock or undefined behaviour may result
  39. ' DOC: It is imperative that DXLockarray8 be matched with DXUnlockArray8 or undefined behaviour may result
  40. ' DOC:
  41. ' DOC: DXLockArray8
  42. ' DOC:       resource    - can be Direct3DTexture8,Direct3dVertexBuffer8, or a Direct3DIndexBuffer
  43. ' DOC:       addr        - is the number provide by IndexBuffer.Lock,Testure.Lock etc
  44. ' DOC:       arr()       - a VB array that can be used to shadow video memory
  45. ' DOC: DXUnlockArray8
  46. ' DOC:       resource    - the resource passed to DXLockArray8
  47. ' DOC:       arr()       - the VB array passed to DXLockArray8
  48. ' DOC:
  49. ' DOC: Example
  50. ' DOC:           dim m_vertBuff as Direct3DVertexBuffer  'we assume this has been created
  51. ' DOC:           dim m_vertCount as long                 'we assume this has been set
  52. ' DOC:
  53. ' DOC:           Dim addr As Long                        'will holds the address the D3D
  54. ' DOC:                                                   'managed memory
  55. ' DOC:           dim verts() as D3DVERTEX                'array that we want to point to
  56. ' DOC:                                                   'D3D managed memory
  57. ' DOC:
  58. ' DOC:           redim verts(m_vertCount)                'ensure the size is large
  59. ' DOC:                                                   'enough for the data and has
  60. ' DOC:                                                   'as many dimensions as needed
  61. ' DOC:                                                   '(1d for vertex buffer, 2d for
  62. ' DOC:                                                   ' surfaces, 3d for volumes)
  63. ' DOC:                                                   'resize the array once and
  64. ' DOC:                                                   'reuse for frequent manipulation
  65. ' DOC:
  66. ' DOC:           m_vertBuff.Lock 0, Len(verts(0)) * m_vertCount, addr, 0
  67. ' DOC:
  68. ' DOC:           DXLockArray8 m_vertBuff, addr, verts
  69. ' DOC:
  70. ' DOC:           for i = 0 to m_vertCount-1
  71. ' DOC:               verts(i).x=i ' or what ever you want to dow with the data
  72. ' DOC:           next
  73. ' DOC:
  74. ' DOC:           DXUnlockArray8 m_vertBuff, verts
  75. ' DOC:
  76. ' DOC:           VB.Unlock
  77. '
  78. Public Declare Function DXLockArray8 Lib "dx8vb.dll" (ByVal resource As Direct3DResource8, ByVal addr As Long, arr() As Any) As Long
  79. Public Declare Function DXUnlockArray8 Lib "dx8vb.dll" (ByVal resource As Direct3DResource8, arr() As Any) As Long
  80.  
  81.  
  82.  
  83. 'DOC: Texture Load data applied to all textures
  84. 'DOC: can be accessed by g_TextureSampling variable
  85. Private Type TextureParams
  86.     enable As Boolean           'enable texture sampling
  87.     
  88.     width As Long               'default width of textures
  89.     height As Long              'default height of textures
  90.     miplevels As Long           'default number of miplevels
  91.     mipfilter As Long           'default mipmap filter
  92.     filter As Long              'default texture filter
  93.     fmt As CONST_D3DFORMAT      'default texture format
  94.     fmtTrans As CONST_D3DFORMAT 'default transparent format
  95.     colorTrans As Long          'default transparent color
  96.     
  97. End Type
  98.  
  99.  
  100. 'DOC: Rotate key used in conjuction with the CD3DAnimation class
  101. Public Type D3DROTATEKEY
  102.     time As Long
  103.     nFloats As Long
  104.     quat As D3DQUATERNION
  105. End Type
  106.  
  107. 'DOC: Scale or Translate key used in conjuction with the CD3DAnimation class
  108. Public Type D3DVECTORKEY
  109.     time As Long
  110.     nFloats As Long
  111.     vec As D3DVECTOR
  112. End Type
  113.  
  114. 'DOC: Pick record using with CD3DPick class
  115. Public Type D3D_PICK_RECORD
  116.     hit As Long
  117.     triFaceid As Long
  118.     a       As Single
  119.     b       As Single
  120.     dist   As Single
  121. End Type
  122.  
  123. 'DOC: see D3DUtil_Timer
  124. Public Enum TIMER_COMMAND
  125.           TIMER_RESET = 1         '- to reset the timer
  126.           TIMER_start = 2         '- to start the timer
  127.           TIMER_STOP = 3          '- to stop (or pause) the timer
  128.           TIMER_ADVANCE = 4       '- to advance the timer by 0.1 seconds
  129.           TIMER_GETABSOLUTETIME = 5 '- to get the absolute system time
  130.           TIMER_GETAPPTIME = 6      '- to get the current time
  131.           TIMER_GETELLAPSEDTIME = 7 '- to get the ellapsed time
  132. End Enum
  133.  
  134.  
  135. 'DOC: Info on a per texture basis
  136. Private Type TexPoolEntry
  137.     Name As String
  138.     tex As Direct3DTexture8
  139.     nextDelNode As Long
  140. End Type
  141.  
  142.  
  143.  
  144. '------------------------------------------------------------------
  145. ' DOC: Usefull globals
  146. '------------------------------------------------------------------
  147.  
  148.  
  149. Public g_bDontDrawTextures As Boolean           ' Debuging switches
  150. Public g_bClipMesh As Boolean                   ' Debuging switches
  151. Public g_bLoadSkins  As Boolean                 ' Debuging switches
  152. Public g_bLoadNoAlpha As Boolean                ' Debuging switches
  153.  
  154.                                                 ' view frustrum (use as read only)
  155. Public g_fov As Single                          ' view frustrum field of view
  156. Public g_aspect As Single                       ' view frustrum aspect ratio
  157. Public g_znear As Single                        ' view frustrum near plane
  158. Public g_zfar As Single                         ' view frustrom far plane
  159.  
  160.                                                 ' Matrices (use as read only)
  161. Public g_identityMatrix As D3DMATRIX            ' Filled with Identity Matrix after D3DUtil_Init
  162. Public g_worldMatrix As D3DMATRIX               ' Filled with current world matrix
  163. Public g_viewMatrix As D3DMATRIX                ' Filled with current view matrix
  164. Public g_projMatrix As D3DMATRIX                ' Filled with current projection matrix
  165.  
  166.                                                 ' Clipplanes: use to ComputeClipPlanes to initialize
  167.                                                 ' helpfull for view frustrum culling
  168. Public g_ClipPlanes() As D3DPLANE               ' Clipplane plane array
  169. Public g_numClipPlanes As Long                  ' Number of clip planes in g_ClipPlanes
  170.  
  171. Public light0 As D3DLIGHT8                      ' light type usefull in imediate pane
  172. Public light1 As D3DLIGHT8                      ' light type usefull in imediate pane
  173.   
  174. Public g_TextureSampling As TextureParams       ' defines how CreateTextureInPool sample textures
  175.  
  176. Public g_TextureLoadCallback  As Object         ' object that implements LoadTextureCallback(sName as string) as Direct3dTexture8
  177. Public g_bUseTextureLoadCallback As Boolean     ' enables disables callback
  178.   
  179. Public g_mediaPath As String                    ' Path to media and texture
  180.                                                 ' read/write - must have ending backslash
  181.                                                 ' best to use SetMediaPath to initialize
  182.  
  183.  
  184.  
  185. '------------------------------------------------------------------
  186. ' Global constants
  187. '------------------------------------------------------------------
  188.  
  189. Public Const g_pi = 3.1415
  190. Public Const g_InvertRotateKey = True   'flag to turn on fix for animation key problem
  191. Public Const D3DFVF_VERTEX = D3DFVF_XYZ Or D3DFVF_NORMAL Or D3DFVF_TEX1
  192.  
  193. '------------------------------------------------------------------
  194. ' Locals
  195. '------------------------------------------------------------------
  196.  
  197. ' TexturePool Mangement data. see..
  198. '  D3DUTIL_LoadTextureIntoPool
  199. '  D3DUTIL_AddTextureToPool
  200. '  D3DUTIL_ReleaseTextureFromPool
  201. '  D3DUTIL_ReleaseAllTexturesFromPool
  202. '
  203. Dim m_texPool() As TexPoolEntry
  204. Dim m_maxPool As Long
  205. Dim m_nextEmpty As Long
  206. Dim m_firstDel As Long
  207.  
  208. Const kGrowSize = 10
  209.  
  210.  
  211. '------------------------------------------------------------------
  212. ' Functions
  213. '------------------------------------------------------------------
  214.  
  215. '-----------------------------------------------------------------------------
  216. 'DOC: D3DUtil_SetupDefaultScene
  217. 'DOC:
  218. 'DOC: helper function that initializes some default lighting and render states
  219. 'DOC:
  220. 'DOC: remarks:
  221. 'DOC:   sets defaults for
  222. 'DOC:   g_fov, g_aspect, g_znear, g_zfar
  223. 'DOC:   g_identityMatrix, g_projMatrix, g_ViewMatrix, g_worldMatrix
  224. 'DOC:   set device state for project view and world matrices
  225. 'DOC:   set device state for 2 directional lights (0 and 1)
  226. 'DOC:   set device state for a default grey material
  227. '-----------------------------------------------------------------------------
  228.  
  229. Public Sub D3DUtil_SetupDefaultScene()
  230.     
  231.     g_fov = g_pi / 4
  232.     g_aspect = 1
  233.     g_znear = 1
  234.     g_zfar = 3000
  235.     
  236.     If g_lWindowHeight <> 0 And g_lWindowWidth <> 0 Then g_aspect = g_lWindowHeight / g_lWindowWidth
  237.     
  238.     D3DXMatrixIdentity g_identityMatrix
  239.     
  240.     D3DXMatrixPerspectiveFovLH g_projMatrix, g_fov, g_aspect, g_znear, g_zfar
  241.     
  242.     g_dev.SetTransform D3DTS_PROJECTION, g_projMatrix
  243.     
  244.     D3DXMatrixLookAtLH g_viewMatrix, vec3(0, 0, -20), vec3(0, 0, 0), vec3(0, 1, 0)
  245.     
  246.     g_dev.SetTransform D3DTS_VIEW, g_viewMatrix
  247.                  
  248.     g_dev.SetTransform D3DTS_WORLD, g_identityMatrix
  249.     
  250.     'default light0
  251.     
  252.     light0.Ambient = ColorValue4(1, 0.1, 0.1, 0.1)
  253.     light0.diffuse = ColorValue4(1, 1, 1, 1)
  254.     light0.Type = D3DLIGHT_DIRECTIONAL
  255.     light0.Range = 10000
  256.     light0.Direction.x = -1
  257.     light0.Direction.y = -1
  258.     light0.Direction.z = -1
  259.     D3DXVec3Normalize light0.Direction, light0.Direction
  260.     g_dev.SetLight 0, light0
  261.     g_dev.LightEnable 0, 1 'true
  262.     
  263.     'default light1
  264.     
  265.     light1.Ambient = ColorValue4(1, 0.3, 0.3, 0.3)
  266.     light1.diffuse = ColorValue4(1, 1, 1, 1)
  267.     light1.Type = D3DLIGHT_DIRECTIONAL
  268.     light1.Range = 10000
  269.     light1.Direction.x = 1
  270.     light1.Direction.y = -1
  271.     light1.Direction.z = -1
  272.     D3DXVec3Normalize light1.Direction, light1.Direction
  273.     'g_dev.SetLight 1, light1
  274.     'g_dev.LightEnable 1, 1 'true
  275.         
  276.         
  277.     'set first material
  278.     Dim material0 As D3DMATERIAL8
  279.     material0.Ambient = ColorValue4(1, 0.2, 0.2, 0.2)
  280.     material0.diffuse = ColorValue4(1, 0.5, 0.5, 0.5)
  281.     material0.power = 10
  282.     g_dev.SetMaterial material0
  283.     
  284.     With g_dev
  285.         Call .SetRenderState(D3DRS_AMBIENT, &H10101010)
  286.         Call .SetRenderState(D3DRS_CLIPPING, 1)             'CLIPPING IS ON
  287.         Call .SetRenderState(D3DRS_LIGHTING, 1)             'LIGHTING IS ON
  288.         Call .SetRenderState(D3DRS_ZENABLE, 1)              'USE ZBUFFER
  289.         Call .SetRenderState(D3DRS_SHADEMODE, D3DSHADE_GOURAUD)
  290.         
  291.     End With
  292.     
  293. End Sub
  294.  
  295.  
  296. '-----------------------------------------------------------------------------
  297. 'DOC: D3DUtil_SetupCamera
  298. 'DOC: Params
  299. 'DOC:   fromV   world space vector of camera position
  300. 'DOC:   toV     world space vector of position camera is looking toward
  301. 'DOC:   upV     world space vector of cameras up direction
  302. 'DOC: Remarks
  303. 'DOC:   effects g_viewMatrix and device ViewMatrix state
  304. 'DOC:   Make sure upV is different than the direction of sight
  305. '-----------------------------------------------------------------------------
  306.  Sub D3DUtil_SetupCamera(fromV As D3DVECTOR, toV As D3DVECTOR, upV As D3DVECTOR)
  307.  
  308.     D3DXMatrixLookAtLH g_viewMatrix, fromV, toV, upV
  309.     g_dev.SetTransform D3DTS_VIEW, g_viewMatrix
  310.     
  311.  End Sub
  312.  
  313.  
  314. '-----------------------------------------------------------------------------
  315. 'DOC: D3DUtil_ClearAll
  316. 'DOC: Params
  317. 'DOC:   col     color to clear the backbuffer
  318. 'DOC: Remarks
  319. 'DOC:   convenience function that assumes a rendertarget with a zbuffer and
  320. 'DOC:   no stencil
  321. '-----------------------------------------------------------------------------
  322.  
  323. Function D3DUtil_ClearAll(col As Long)
  324.     g_dev.Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, col, 1, 0
  325. End Function
  326.  
  327.  
  328.  
  329.  
  330. '-----------------------------------------------------------------------------
  331. 'DOC: D3DUtil_PresentAll
  332. 'DOC: Params
  333. 'DOC:   hwnd    hwnd to present to
  334. 'DOC: Remarks
  335. 'DOC:   Convience function that presents the contents of a backbuffer to an hwnd
  336. 'DOC:
  337. '-----------------------------------------------------------------------------
  338. Function D3DUtil_PresentAll(hwnd As Long)
  339.     On Local Error Resume Next
  340.     g_dev.Present ByVal 0, ByVal 0, hwnd, ByVal 0
  341.     
  342.     'some video cards leave the divide by zero flag set after Present or EndScene
  343.     'here we force a divide by zero to force vb to reset the flag so the next
  344.     'math operation doesnt give a divide by zero error
  345.     Dim dummy As Single
  346.     dummy = dummy / 0
  347.     Err.Clear
  348.     
  349. End Function
  350.  
  351.  
  352. '-----------------------------------------------------------------------------
  353. 'DOC: ColorValue4
  354. 'DOC: Params
  355. 'DOC:   a r g b   values valid between 0.0 and 1.0
  356. 'DOC: Return Value
  357. 'DOC:   a filled D3DCOLORVALUE type
  358. '-----------------------------------------------------------------------------
  359. Function ColorValue4(a As Single, r As Single, g As Single, b As Single) As D3DCOLORVALUE
  360.     Dim c As D3DCOLORVALUE
  361.     c.a = a
  362.     c.r = r
  363.     c.g = g
  364.     c.b = b
  365.     ColorValue4 = c
  366. End Function
  367.  
  368. '-----------------------------------------------------------------------------
  369. 'DOC: Vec2
  370. 'DOC: Params
  371. 'DOC:   x y z   vector values
  372. 'DOC: Return Value
  373. 'DOC:   a filled D3DVECTOR type
  374. '-----------------------------------------------------------------------------
  375. Function vec2(x As Single, y As Single) As D3DVECTOR2
  376.     vec2.x = x
  377.     vec2.y = y
  378. End Function
  379.  
  380.  
  381. '-----------------------------------------------------------------------------
  382. 'DOC: Vec3
  383. 'DOC: Params
  384. 'DOC:   x y z   vector values
  385. 'DOC: Return Value
  386. 'DOC:   a filled D3DVECTOR type
  387. '-----------------------------------------------------------------------------
  388. Function vec3(x As Single, y As Single, z As Single) As D3DVECTOR
  389.     vec3.x = x
  390.     vec3.y = y
  391.     vec3.z = z
  392. End Function
  393.  
  394.  
  395. '-----------------------------------------------------------------------------
  396. 'DOC: Vec4
  397. 'DOC: Params
  398. 'DOC:   x y z w  vector values
  399. 'DOC: Return Value
  400. 'DOC:   a filled D3DVECTOR type
  401. '-----------------------------------------------------------------------------
  402. Function vec4(x As Single, y As Single, z As Single, w As Single) As D3DVECTOR4
  403.     vec4.x = x
  404.     vec4.y = y
  405.     vec4.z = z
  406.     vec4.w = w
  407. End Function
  408.  
  409.  
  410. '-----------------------------------------------------------------------------
  411. 'DOC: D3DUtil_RotationAxis
  412. 'DOC: Params
  413. 'DOC:   x y z               axis of rotation
  414. 'DOC:   rotationInDegrees   rotationInDegrees
  415. 'DOC:
  416. 'DOC: Return Value
  417. 'DOC:   a filled D3DQUATERNION type
  418. '-----------------------------------------------------------------------------
  419. Function D3DUtil_RotationAxis(x As Single, y As Single, z As Single, rotationInDegrees As Single) As D3DQUATERNION
  420.     Dim quat As D3DQUATERNION
  421.     D3DXQuaternionRotationAxis quat, vec3(x, y, z), (rotationInDegrees / 180) * g_pi
  422.     D3DUtil_RotationAxis = quat
  423. End Function
  424.  
  425.  
  426.  
  427. '-----------------------------------------------------------------------------
  428. 'DOC: D3DUtil_CreateTexture()
  429. 'DOC: Params
  430. 'DOC:   dev     Direct3DDevice  (almost always g_dev)
  431. 'DOC:   strFile name of the file to load
  432. 'DOC:   fmt     prefered format (may be UNKNOWN)
  433. 'DOC: Return Value
  434. 'DOC:   a Direct3DTexture object
  435. 'DOC: Remarks
  436. 'DOC:   Helper function to create a texture. It checks the root path first,
  437. 'DOC:   then tries the media path (as set by setMediaPath)
  438. '------------------------------------------------------------------------------
  439.  
  440. Function D3DUtil_CreateTexture(dev As Direct3DDevice8, strFile As String, fmt As CONST_D3DFORMAT) As Direct3DTexture8
  441.  
  442.     On Local Error GoTo errOut
  443.     Dim strPath As String
  444.     Dim tex As Direct3DTexture8
  445.     
  446.     strPath = strFile
  447.     If Dir$(strFile) = "" Then strPath = g_mediaPath + strFile
  448.     
  449.     Set tex = g_d3dx.CreateTextureFromFileEx(dev, strPath, _
  450.                         D3DX_DEFAULT, D3DX_DEFAULT, D3DX_DEFAULT, 0, _
  451.                         fmt, D3DPOOL_MANAGED, D3DX_DEFAULT, D3DX_DEFAULT, 0, ByVal 0, ByVal 0)
  452.     
  453.     Set D3DUtil_CreateTexture = tex
  454.     Exit Function
  455.     
  456. errOut:
  457.     Set D3DUtil_CreateTexture = Nothing
  458. End Function
  459.  
  460.  
  461.  
  462. '-----------------------------------------------------------------------------
  463. 'DOC: D3DUtil_CreateTextureInPool()
  464. 'DOC: Params
  465. 'DOC:   dev     Direct3DDevice (all most always g_dev)
  466. 'DOC:   strFile name of the texture to load
  467. 'DOC:   fmt     prefered format (may be UNKNOWN)
  468. 'DOC: Return Value
  469. 'DOC:   a Direct3DTexture object
  470. 'DOC: Remarks
  471. 'DOC:   Helper function to create a texture. It checks the root path first,
  472. 'DOC:   then tries the media path (as set by setMediaPath)
  473. 'DOC:   This function differs from D3DUtil_CreateTexture in that
  474. 'DOC:   Multiple calls with the same texture name will result in
  475. 'DOC:   returning the same texture object
  476. 'DOC:   To release all texture to allow a device change see
  477. 'DOC:   D3DUtil_ReleaseAllTexturesFromPool
  478. '-----------------------------------------------------------------------------
  479.  
  480. Function D3DUtil_CreateTextureInPool(dev As Direct3DDevice8, strFile As String, ByVal fmt As CONST_D3DFORMAT) As Direct3DTexture8
  481.     
  482.     Debug.Print strFile
  483.               
  484.     On Local Error GoTo errOut
  485.       
  486.     Dim strPath As String
  487.     Dim tex As Direct3DTexture8
  488.     
  489.     Dim transcolor As Long
  490.     Dim miplev As Long
  491.     Dim filter As Long
  492.     Dim mipfilter As Long
  493.     Dim w As Long
  494.     Dim h As Long
  495.     
  496.     If strFile = "" Then Exit Function
  497.     
  498.     Set tex = D3DUtil_FindTextureInPool(strFile)
  499.     If Not tex Is Nothing Then
  500.         Set D3DUtil_CreateTextureInPool = tex
  501.         Exit Function
  502.     End If
  503.         
  504.     
  505.     strPath = strFile
  506.     If Dir$(strFile) = "" Then strPath = g_mediaPath + strFile
  507.     
  508.     
  509.     If Not g_TextureSampling.enable Then
  510.         fmt = D3DFMT_UNKNOWN
  511.         miplev = D3DX_DEFAULT
  512.         filter = D3DX_DEFAULT
  513.         mipfilter = D3DX_DEFAULT
  514.         w = D3DX_DEFAULT
  515.         h = D3DX_DEFAULT
  516.         transcolor = 0
  517.     Else
  518.         miplev = g_TextureSampling.miplevels
  519.         filter = g_TextureSampling.filter
  520.         mipfilter = g_TextureSampling.mipfilter
  521.         w = g_TextureSampling.width
  522.         h = g_TextureSampling.height
  523.         fmt = g_TextureSampling.fmt
  524.         transcolor = 0
  525.     End If
  526.      
  527.     'Check for color keys
  528.     If (InStr(strFile, "_t.") <> 0) And g_TextureSampling.enable Then
  529.        fmt = g_TextureSampling.fmtTrans
  530.        transcolor = g_TextureSampling.colorTrans Or &HFF000000
  531.     End If
  532.             
  533.     If (InStr(strFile, ".tif") <> 0) Then
  534.         transcolor = 0
  535.         fmt = g_TextureSampling.fmtTrans
  536.     End If
  537.     
  538.     Set tex = g_d3dx.CreateTextureFromFileEx(dev, strPath, _
  539.                    w, h, miplev, 0, fmt, D3DPOOL_MANAGED, _
  540.                    filter, mipfilter, transcolor, ByVal 0, ByVal 0)
  541.          
  542.     D3DUtil_AddTextureToPool tex, strFile
  543.     
  544.     Set D3DUtil_CreateTextureInPool = tex
  545.     Exit Function
  546.     
  547. errOut:
  548.     Set D3DUtil_CreateTextureInPool = Nothing
  549. End Function
  550.  
  551. '-----------------------------------------------------------------------------
  552. 'DOC: D3DUtil_ReleaseTextureFromPool()
  553. 'DOC: Params
  554. 'DOC:   strFileName name of the texture to release
  555. '-----------------------------------------------------------------------------
  556.  
  557. Sub D3DUtil_ReleaseTextureFromPool(strFileName As String)
  558.     Dim i As Long
  559.     For i = 0 To m_nextEmpty - 1
  560.         If (m_texPool(i).Name = strFileName) Then
  561.             m_texPool(i).nextDelNode = m_firstDel
  562.             m_firstDel = i
  563.             m_texPool(i).Name = ""
  564.             Set m_texPool(i).tex = Nothing
  565.             Exit Sub
  566.         End If
  567.     Next
  568. End Sub
  569.  
  570.  
  571. '-----------------------------------------------------------------------------
  572. 'DOC: D3DUtil_FindTextureInPool
  573. 'DOC: Params
  574. 'DOC:   strFileName name of the texture to release
  575. 'DOC: Return value
  576. 'DOC:   texture that was found or Nothing if name not found
  577. 'DOC:   Will return the first match. Is case sensitive
  578. '-----------------------------------------------------------------------------
  579.  
  580. Function D3DUtil_FindTextureInPool(strFileName As String) As Direct3DTexture8
  581.     Dim i As Long
  582.     For i = 0 To m_nextEmpty - 1
  583.         If (m_texPool(i).Name = strFileName) Then
  584.             Set D3DUtil_FindTextureInPool = m_texPool(i).tex
  585.             Exit Function
  586.         End If
  587.     Next
  588. End Function
  589.  
  590.  
  591. '-----------------------------------------------------------------------------
  592. 'DOC: D3DUtil_ReleaseAllTexturesFromPool()
  593. 'DOC: Remarks
  594. 'DOC:   Release all textures from the pool
  595. 'DOC:   This is required before attempting to completely release a device
  596. 'DOC:   as the device still exists until all objects created from it
  597. 'DOC:   are also released or set to Nothing
  598. '-----------------------------------------------------------------------------
  599.  
  600. Sub D3DUtil_ReleaseAllTexturesFromPool()
  601.     ReDim m_texPool(0)
  602.     m_firstDel = -1
  603.     m_nextEmpty = 0
  604.     m_maxPool = 0
  605. End Sub
  606.  
  607. '-----------------------------------------------------------------------------
  608. 'DOC: D3DUtil_AddTextureToPool
  609. 'DOC: Params
  610. 'DOC:   tex         Direct3DTexture to add
  611. 'DOC:   strFile     name to associate with texture
  612. 'DOC: Remarks
  613. 'DOC:   Be aware that the Texture pool names are case sensitive
  614. '-----------------------------------------------------------------------------
  615.  
  616. Function D3DUtil_AddTextureToPool(tex As Direct3DTexture8, strFile As String)
  617.     
  618.     'If the list is empty - makeit
  619.     If m_maxPool = 0 Then
  620.         ReDim m_texPool(kGrowSize)
  621.         m_maxPool = kGrowSize
  622.         m_firstDel = -1
  623.         Set m_texPool(0).tex = tex
  624.         m_texPool(0).Name = strFile
  625.         m_texPool(0).nextDelNode = -1
  626.         Exit Function
  627.     End If
  628.     
  629.     'If there are items that are deleted then
  630.     'use there slots
  631.     If m_firstDel > -1 Then
  632.         Set m_texPool(m_firstDel).tex = tex
  633.         m_texPool(m_firstDel).Name = strFile
  634.         m_firstDel = m_texPool(m_firstDel).nextDelNode
  635.         m_texPool(m_firstDel).nextDelNode = -1
  636.         Exit Function
  637.     End If
  638.     
  639.     'If there are no slots left create a slot
  640.     If m_maxPool <= m_nextEmpty Then
  641.         m_maxPool = m_maxPool + kGrowSize
  642.         ReDim Preserve m_texPool(m_maxPool)
  643.     End If
  644.     
  645.     'assign the entry to the next available slot
  646.     Set m_texPool(m_nextEmpty).tex = tex
  647.     m_texPool(m_nextEmpty).Name = strFile
  648.     m_texPool(m_nextEmpty).nextDelNode = -1
  649.     m_nextEmpty = m_nextEmpty + 1
  650.     
  651.         
  652. End Function
  653.  
  654. '-----------------------------------------------------------------------------
  655. 'DOC: D3DUtil_SetTextureLoadCallback
  656. 'DOC:
  657. 'DOC: Params
  658. 'DOC:   obj     can equal nothing to remove the callback from use
  659. 'DOC:           or an object that implements
  660. 'DOC:           LoadTextureCallback(sName as string) as Direct3dTexture8
  661. 'DOC:
  662. '-----------------------------------------------------------------------------
  663. Sub D3DUtil_SetTextureLoadCallback(obj As Object)
  664.     Set g_TextureLoadCallback = obj
  665.     
  666.     g_bUseTextureLoadCallback = False
  667.     If obj Is Nothing Then Exit Sub
  668.     
  669.     g_bUseTextureLoadCallback = True
  670. End Sub
  671.  
  672.  
  673. '-----------------------------------------------------------------------------
  674. 'DOC: D3DUtil_SetTextureSampling
  675. 'DOC:
  676. 'DOC: Params
  677. 'DOC:      bEnable     Enable/Disable sampling defaults
  678. 'DOC:      w           default width for all textures
  679. 'DOC:      h           default height for all texture
  680. 'DOC:      levels      default number of miplevels
  681. 'DOC:      fmt         default texture format
  682. 'DOC:      transfmt    default texture format for alpha textures
  683. 'DOC:      transcolor  transparent color to mask for textures with file names
  684. 'DOC:                  ending in xxxx_t.bmp or xxxx_t.yyy
  685. '-----------------------------------------------------------------------------
  686. Sub D3DUtil_SetTextureSampling(bEnable As Boolean, w As Long, h As Long, levels As Long, fmt As CONST_D3DFORMAT, transfmt As CONST_D3DFORMAT, transcolor As Long)
  687.     With g_TextureSampling
  688.         .enable = bEnable
  689.         .width = w
  690.         .height = h
  691.         .miplevels = levels
  692.         .mipfilter = D3DX_FILTER_BOX
  693.         .filter = D3DX_FILTER_BOX
  694.         .fmt = fmt
  695.         .colorTrans = transcolor
  696.         .fmtTrans = transfmt
  697.     End With
  698. End Sub
  699.  
  700.  
  701. '-----------------------------------------------------------------------------
  702. 'DOC: D3DUtil_CreateFrame
  703. 'DOC:
  704. 'DOC: Params:
  705. 'DOC:       parent      Parent whos child is the returned frame
  706. 'DOC:                   can be Nothing
  707. 'DOC:
  708. 'DOC: Returns
  709. 'DOC:       New Frame object
  710. '-----------------------------------------------------------------------------
  711. Function D3DUtil_CreateFrame(parent As CD3DFrame) As CD3DFrame
  712.     Set D3DUtil_CreateFrame = New CD3DFrame
  713.     If parent Is Nothing Then Exit Function
  714.     parent.AddChild D3DUtil_CreateFrame
  715. End Function
  716.  
  717.  
  718. '-----------------------------------------------------------------------------
  719. ' Name: D3DUtil_LoadFromFile
  720. '-----------------------------------------------------------------------------
  721. Function D3DUtil_LoadFromFile(strFile As String, parentFrame As CD3DFrame, parentAnimation As CD3DAnimation) As CD3DFrame
  722.     On Local Error GoTo errOut
  723.     Dim newFrame As CD3DFrame
  724.     Set newFrame = New CD3DFrame
  725.     
  726.     g_bLoadSkins = False
  727.     newFrame.InitFromFile g_dev, strFile, parentFrame, parentAnimation
  728.     Set D3DUtil_LoadFromFile = newFrame
  729.     
  730.     'CONSIDER the need to set the FVF on load.
  731.     newFrame.SetFVF g_dev, D3DFVF_VERTEX
  732.     Exit Function
  733.     
  734. errOut:
  735.     Set D3DUtil_LoadFromFile = Nothing
  736. End Function
  737.  
  738.  
  739. '-----------------------------------------------------------------------------
  740. ' Name: D3DUtil_LoadFromFileAsSkin
  741. '-----------------------------------------------------------------------------
  742. Function D3DUtil_LoadFromFileAsSkin(strFile As String, parentFrame As CD3DFrame, parentAnimation As CD3DAnimation) As CD3DFrame
  743.     On Local Error GoTo errOut
  744.     Dim newFrame As CD3DFrame
  745.     Set newFrame = New CD3DFrame
  746.     g_bLoadSkins = True
  747.     newFrame.InitFromFile g_dev, strFile, parentFrame, parentAnimation
  748.     newFrame.AttatchBonesToMesh newFrame
  749.     Set D3DUtil_LoadFromFileAsSkin = newFrame
  750.     Exit Function
  751.     
  752. errOut:
  753.     Set D3DUtil_LoadFromFileAsSkin = Nothing
  754. End Function
  755.  
  756.  
  757. '-----------------------------------------------------------------------------
  758. ' Name: D3DUtil_LoadFromFileAsMesh
  759. '-----------------------------------------------------------------------------
  760. Function D3DUtil_LoadFromFileAsMesh(strFile As String) As CD3DMesh
  761.     On Local Error GoTo errOut
  762.     Dim newmesh As CD3DMesh
  763.     Set newmesh = New CD3DMesh
  764.     newmesh.InitFromFile g_dev, strFile
  765.     Set D3DUtil_LoadFromFileAsMesh = newmesh
  766.     newmesh.SetFVF g_dev, D3DFVF_VERTEX
  767.     Exit Function
  768.     
  769. errOut:
  770.     Set D3DUtil_LoadFromFileAsMesh = Nothing
  771. End Function
  772.  
  773. '-----------------------------------------------------------------------------
  774. ' Name: D3DUtil_SetMediaPath
  775. '-----------------------------------------------------------------------------
  776. Sub D3DUtil_SetMediaPath(path As String)
  777.     g_mediaPath = path
  778. End Sub
  779.  
  780.  
  781.  
  782. '-----------------------------------------------------------------------------
  783. ' Name: D3DUtil_InitLight
  784. '-----------------------------------------------------------------------------
  785. Sub D3DUtil_InitLight(lgt As D3DLIGHT8, ty As CONST_D3DLIGHTTYPE, x As Single, y As Single, z As Single)
  786.     lgt.Type = ty
  787.     lgt.diffuse = ColorValue4(1, 1, 1, 1)
  788.     lgt.Attenuation1 = 0.01
  789.     lgt.Attenuation0 = 0
  790.     lgt.Attenuation2 = 0
  791.     lgt.Range = 99999999
  792.     lgt.Direction.x = x
  793.     lgt.Direction.y = y
  794.     lgt.Direction.z = z
  795.     lgt.position.x = x
  796.     lgt.position.y = y
  797.     lgt.position.z = z
  798.     
  799.           
  800. End Sub
  801.  
  802.  
  803. '-----------------------------------------------------------------------------
  804. ' Name: D3DUtil_ComputeClipPlanes
  805. '-----------------------------------------------------------------------------
  806. Sub D3DUtil_ComputeClipPlanes(veye As D3DVECTOR, vat As D3DVECTOR, vUp As D3DVECTOR, fov As Single, front As Single, back As Single, aspect As Single)
  807.     
  808.     Dim vDir As D3DVECTOR
  809.     Dim vright As D3DVECTOR
  810.         
  811.     Dim vFrontCenter As D3DVECTOR
  812.     Dim vFrontUp As D3DVECTOR
  813.     Dim vFrontRight As D3DVECTOR
  814.     
  815.     Dim vBackCenter As D3DVECTOR
  816.     
  817.     Dim vBackRight As D3DVECTOR
  818.     Dim vbackLeft As D3DVECTOR
  819.     
  820.     Dim vBackRightTop As D3DVECTOR
  821.     Dim vBackLeftTop As D3DVECTOR
  822.     
  823.     Dim vBackRightBot As D3DVECTOR
  824.     Dim vBackLeftBot As D3DVECTOR
  825.         
  826.     Dim dx As Single
  827.     Dim dy As Single
  828.     
  829.     'Establish our basis vector
  830.     D3DXVec3Subtract vDir, vat, veye
  831.     D3DXVec3Normalize vDir, vDir
  832.     D3DXVec3Normalize vUp, vUp
  833.     D3DXVec3Cross vright, vDir, vUp
  834.     
  835.     dx = Tan(fov / 2) * back
  836.     dy = dx * aspect
  837.         
  838.     '
  839.     '
  840.     '              /|  vbackleft (top,bot)
  841.     '             / |
  842.     '        vfront |
  843.     '           /|  |
  844.     '       eye ----|  vbackcenter
  845.     '           \|  |
  846.     '            \  |dx
  847.     '             \ |
  848.     '              \|  vbackright (top,bot)
  849.     '
  850.     '
  851.     
  852.     
  853.     'compute vbackcenter
  854.     D3DXVec3Scale vBackCenter, vDir, back
  855.     D3DXVec3Add vBackCenter, vBackCenter, veye
  856.     
  857.        
  858.     'compute vbackright
  859.     D3DXVec3Scale vBackRight, vright, dx
  860.     D3DXVec3Add vBackRight, vBackCenter, vBackRight
  861.     
  862.     
  863.     'compute vbackleft
  864.     D3DXVec3Scale vbackLeft, vright, -dx
  865.     D3DXVec3Add vbackLeft, vBackCenter, vbackLeft
  866.  
  867.     'compute vbackrighttop
  868.     D3DXVec3Scale vBackRightTop, vUp, dy
  869.     D3DXVec3Add vBackRightTop, vBackRight, vBackRightTop
  870.     
  871.     
  872.     'compute vbacklefttop
  873.     D3DXVec3Scale vBackLeftTop, vUp, dy
  874.     D3DXVec3Add vBackLeftTop, vBackRight, vBackLeftTop
  875.         
  876.      'compute vbackrightbot
  877.     D3DXVec3Scale vBackRightBot, vUp, -dy
  878.     D3DXVec3Add vBackRightBot, vBackRight, vBackRightBot
  879.        
  880.     'compute vbackleftbot
  881.     D3DXVec3Scale vBackLeftBot, vUp, -dy
  882.     D3DXVec3Add vBackLeftBot, vBackRight, vBackLeftBot
  883.     
  884.         
  885.     'compute vfrontcenter
  886.     D3DXVec3Scale vFrontCenter, vDir, front
  887.     D3DXVec3Add vFrontCenter, vFrontCenter, veye
  888.  
  889.     'compute vfrontright
  890.     D3DXVec3Scale vFrontRight, vright, dx
  891.     D3DXVec3Add vFrontRight, vFrontCenter, vFrontRight
  892.  
  893.     'compute vfrontup
  894.     D3DXVec3Scale vFrontUp, vUp, dy
  895.     D3DXVec3Add vFrontUp, vFrontCenter, vFrontUp
  896.  
  897.     ReDim g_ClipPlanes(6)
  898.     g_numClipPlanes = 6
  899.     
  900.     
  901.     
  902.     'front plane
  903.     D3DXPlaneFromPointNormal g_ClipPlanes(0), veye, vDir
  904.     
  905.     'back plane
  906.     Dim vnegdir As D3DVECTOR
  907.     D3DXVec3Scale vnegdir, vDir, -1
  908.     D3DXPlaneFromPointNormal g_ClipPlanes(1), vBackCenter, vnegdir
  909.     
  910.     'right plane
  911.     D3DXPlaneFromPoints g_ClipPlanes(2), veye, vBackRightTop, vBackRightBot
  912.     
  913.     'left plane
  914.     D3DXPlaneFromPoints g_ClipPlanes(3), veye, vBackLeftTop, vBackLeftBot
  915.     
  916.     'top plane
  917.     D3DXPlaneFromPoints g_ClipPlanes(4), veye, vBackLeftTop, vBackRightTop
  918.     
  919.     'bot plane
  920.     D3DXPlaneFromPoints g_ClipPlanes(5), veye, vBackRightBot, vBackLeftBot
  921.     
  922.     g_numClipPlanes = 4
  923.     
  924. End Sub
  925.  
  926.  
  927. '-----------------------------------------------------------------------------
  928. 'DOC: D3DUtil_IntersectTriangleCull
  929. 'DOC: Params
  930. 'DOC:   v0,v1,v2    points from a triangle
  931. 'DOC:   vDir        direction vector of a ray to intersect triangle
  932. 'DOC:   vOrig       origen of ray to interesect triangle
  933. 'DOC:   t           distance from origen to intersection
  934. 'DOC:   u,v         u v coordinates of intersection
  935. 'DOC: Return value
  936. 'DOC:   true if intersected, false if not
  937. 'DOC:
  938. 'DOC: See CD3DPick object if intersecting a ray with a mesh or frame
  939. '-----------------------------------------------------------------------------
  940.  
  941. Function D3DUtil_IntersectTriangleCull(ByRef v0 As D3DVECTOR, ByRef v1 As D3DVECTOR, ByRef v2 As D3DVECTOR, vDir As D3DVECTOR, vOrig As D3DVECTOR, t As Single, u As Single, v As Single) As Boolean
  942.  
  943.     Dim edge1 As D3DVECTOR
  944.     Dim edge2 As D3DVECTOR
  945.     Dim pvec As D3DVECTOR
  946.     Dim tvec As D3DVECTOR
  947.     Dim qvec As D3DVECTOR
  948.     Dim det As Single
  949.     Dim fInvDet As Single
  950.     
  951.     'find vectors for the two edges sharing vert0
  952.     D3DXVec3Subtract edge1, v1, v0
  953.     D3DXVec3Subtract edge2, v2, v0
  954.     
  955.     'begin calculating the determinant - also used to caclulate u parameter
  956.     D3DXVec3Cross pvec, vDir, edge2
  957.     
  958.     'if determinant is nearly zero, ray lies in plane of triangle
  959.     det = D3DXVec3Dot(edge1, pvec)
  960.     If (det < 0.0001) Then
  961.         Exit Function
  962.     End If
  963.     
  964.     'calculate distance from vert0 to ray origin
  965.     D3DXVec3Subtract tvec, vOrig, v0
  966.  
  967.     'calculate u parameter and test bounds
  968.     u = D3DXVec3Dot(tvec, pvec)
  969.     If (u < 0 Or u > det) Then
  970.         Exit Function
  971.     End If
  972.     
  973.     'prepare to test v parameter
  974.     D3DXVec3Cross qvec, tvec, edge1
  975.     
  976.     'calculate v parameter and test bounds
  977.     v = D3DXVec3Dot(vDir, qvec)
  978.     If (v < 0 Or (u + v > det)) Then
  979.         Exit Function
  980.     End If
  981.     
  982.     'calculate t, scale parameters, ray intersects triangle
  983.     t = D3DXVec3Dot(edge2, qvec)
  984.     fInvDet = 1 / det
  985.     t = t * fInvDet
  986.     u = u * fInvDet
  987.     v = v * fInvDet
  988.     If t = 0 Then Exit Function
  989.     
  990.     D3DUtil_IntersectTriangleCull = True
  991.     
  992. End Function
  993.  
  994.  
  995. '-----------------------------------------------------------------------------
  996. ' Name: D3DUtil_IsSphereVisible
  997. '-----------------------------------------------------------------------------
  998. Function D3DUtil_IsSphereVisible(SphereCenterInWorldSpace As D3DVECTOR, SphereRadius As Single) As Long
  999.     
  1000.     Dim i As Long
  1001.     Dim dist As Single
  1002.     
  1003.     For i = 0 To g_numClipPlanes - 1
  1004.         dist = D3DXMATH_PLANE.D3DXPlaneDotCoord(g_ClipPlanes(i), SphereCenterInWorldSpace)
  1005.         If dist < -1 * SphereRadius Then
  1006.             'sphere is completely behind the plane
  1007.             'if its behind any plane then its clipped
  1008.             'Debug.Print SphereRadius
  1009. '            If i = 2 Then Stop
  1010.             D3DUtil_IsSphereVisible = 0
  1011.             Exit Function
  1012.         End If
  1013.     Next
  1014.  
  1015.     D3DUtil_IsSphereVisible = 1
  1016.     
  1017. End Function
  1018.  
  1019.  
  1020.  
  1021. '-----------------------------------------------------------------------------
  1022. ' Name: D3DPLANE4
  1023. '-----------------------------------------------------------------------------
  1024. Function D3DPLANE4(a As Single, b As Single, c As Single, d As Single) As D3DPLANE
  1025.     
  1026.     D3DPLANE4.a = a
  1027.     D3DPLANE4.b = b
  1028.     D3DPLANE4.c = c
  1029.     D3DPLANE4.d = d
  1030.     
  1031. End Function
  1032.  
  1033. '-----------------------------------------------------------------------------
  1034. ' Name: FtoDW
  1035. '
  1036. ' For calls that require that a single be packed into a long
  1037. ' (such as some calls to SetRenderState) this function will do just that
  1038. '-----------------------------------------------------------------------------
  1039. Function FtoDW(f As Single) As Long
  1040.     Dim buf As D3DXBuffer
  1041.     Dim l As Long
  1042.     Set buf = g_d3dx.CreateBuffer(4)
  1043.     g_d3dx.BufferSetData buf, 0, 4, 1, f
  1044.     g_d3dx.BufferGetData buf, 0, 4, 1, l
  1045.     FtoDW = l
  1046. End Function
  1047.  
  1048. '-----------------------------------------------------------------------------
  1049. ' Name: LONGtoD3DCOLORVALUE
  1050. '-----------------------------------------------------------------------------
  1051. Function LONGtoD3DCOLORVALUE(color As Long) As D3DCOLORVALUE
  1052.     Dim a As Long, r As Long, g As Long, b As Long
  1053.         
  1054.     If color < 0 Then
  1055.         a = ((color And (&H7F000000)) / (2 ^ 24)) Or &H80&
  1056.     Else
  1057.         a = color / (2 ^ 24)
  1058.     End If
  1059.     r = (color And &HFF0000) / (2 ^ 16)
  1060.     g = (color And &HFF00&) / (2 ^ 8)
  1061.     b = (color And &HFF&)
  1062.     
  1063.     LONGtoD3DCOLORVALUE.a = a / 255
  1064.     LONGtoD3DCOLORVALUE.r = r / 255
  1065.     LONGtoD3DCOLORVALUE.g = g / 255
  1066.     LONGtoD3DCOLORVALUE.b = b / 255
  1067.         
  1068. End Function
  1069.  
  1070.  
  1071. '-----------------------------------------------------------------------------
  1072. ' Name: D3DCOLORVALUEtoLONG
  1073. '-----------------------------------------------------------------------------
  1074.  
  1075. Function D3DCOLORVALUEtoLONG(cv As D3DCOLORVALUE) As Long
  1076.     Dim r As Long
  1077.     Dim g As Long
  1078.     Dim b As Long
  1079.     Dim a As Long
  1080.     Dim c As Long
  1081.     
  1082.     r = cv.r * 255
  1083.     g = cv.g * 255
  1084.     b = cv.b * 255
  1085.     a = cv.a * 255
  1086.     
  1087.     If a > 127 Then
  1088.         a = a - 128
  1089.         c = a * 2 ^ 24 Or &H80000000
  1090.         c = c Or r * 2 ^ 16
  1091.         c = c Or g * 2 ^ 8
  1092.         c = c Or b
  1093.     Else
  1094.         c = a * 2 ^ 24
  1095.         c = c Or r * 2 ^ 16
  1096.         c = c Or g * 2 ^ 8
  1097.         c = c Or b
  1098.     End If
  1099.     
  1100.     D3DCOLORVALUEtoLONG = c
  1101. End Function
  1102.  
  1103. '-----------------------------------------------------------------------------
  1104. ' Name: DXUtil_Timer()
  1105. ' Desc: Performs timer opertations. Use the following commands:
  1106. '          TIMER_RESET           - to reset the timer
  1107. '          TIMER_START           - to start the timer
  1108. '          TIMER_STOP            - to stop (or pause) the timer
  1109. '          TIMER_ADVANCE         - to advance the timer by 0.1 seconds
  1110. '          TIMER_GETABSOLUTETIME - to get the absolute system time
  1111. '          TIMER_GETAPPTIME      - to get the current time
  1112. '          TIMER_GETELLAPSEDTIME - to get the ellapsed time between calls
  1113. '-----------------------------------------------------------------------------
  1114. Function DXUtil_Timer(command As TIMER_COMMAND) As Single
  1115.  
  1116.     On Local Error Resume Next
  1117.  
  1118.     Static m_bTimerInitialized  As Boolean
  1119.     Static m_bUsingQPF         As Boolean
  1120.     Static m_fSecsPerTick  As Single
  1121.     Static m_fBaseTime    As Single
  1122.     Static m_fStopTime     As Single
  1123.     Static m_fLastTime As Single
  1124.     
  1125.     Dim fTime As Single
  1126.  
  1127.     ' Initialize the timer
  1128.     If (False = m_bTimerInitialized) Then
  1129.         m_bTimerInitialized = True
  1130.     End If
  1131.  
  1132.     If m_fLastTime > Timer Then command = TIMER_RESET 'For the midnight wrap
  1133.     fTime = Timer
  1134.  
  1135.     ' Reset the timer
  1136.     If (command = TIMER_RESET) Then
  1137.         m_fBaseTime = fTime
  1138.         m_fStopTime = 0
  1139.         m_fLastTime = 0
  1140.         DXUtil_Timer = 0
  1141.         Exit Function
  1142.     End If
  1143.  
  1144.     ' Return the current time
  1145.     If (command = TIMER_GETAPPTIME) Then
  1146.         DXUtil_Timer = fTime - m_fBaseTime
  1147.         Exit Function
  1148.     End If
  1149.  
  1150.     ' Start the timer
  1151.     If (command = TIMER_start) Then
  1152.         m_fBaseTime = m_fBaseTime + fTime - m_fStopTime
  1153.         m_fLastTime = m_fLastTime + fTime - m_fStopTime
  1154.         m_fStopTime = 0
  1155.     End If
  1156.     
  1157.     ' Stop the timer
  1158.     If (command = TIMER_STOP) Then
  1159.         m_fStopTime = fTime
  1160.     End If
  1161.      
  1162.     ' Advance the timer by 1/10th second
  1163.     If (command = TIMER_ADVANCE) Then
  1164.         m_fBaseTime = m_fBaseTime + fTime - (m_fStopTime + 0.1)
  1165.     End If
  1166.     
  1167.     
  1168.     ' Return ellapsed time
  1169.     If (command = TIMER_GETELLAPSEDTIME) Then
  1170.         DXUtil_Timer = fTime - m_fLastTime
  1171.         m_fLastTime = fTime
  1172.         If DXUtil_Timer < 0 Then DXUtil_Timer = 0
  1173.         Exit Function
  1174.     End If
  1175.     
  1176.     
  1177.     DXUtil_Timer = fTime
  1178. End Function
  1179.  
  1180.  
  1181.  
  1182.  
  1183.